home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / MacQForth 1.0 / source / MacQForth Source / Traps.mops < prev    next >
Text File  |  1995-04-04  |  4KB  |  153 lines
  1. \ Section: Monitor and Extension Traps
  2.  
  3. 6 constant dx  \ horizontal differential
  4. 0B constant dy  \ vertical differential
  5.  
  6. variable theText 77C allot \ 1840 characters = 23 x 80 plus extra
  7.  \ blank line for scrolling
  8.  
  9. : $DB  \ trap CH word, set horizontal position
  10.    rY @ dx * 2+ @xy swap drop gotoxy
  11. ;
  12.  
  13. : $DF  \ trap CV word, set vertical position
  14.    @xy drop rY @ dy * 4+ gotoxy
  15. ;
  16.  
  17. : clrText ( -- ) \ clear the text buffer
  18.    780 theText + theText do  20 i c!  loop ;
  19.  
  20. : killText ( -- ) \ remove the top line in theText
  21.    780 theText + theText 50 + do
  22.      i c@  i 50 - c!  \ move all text up one line
  23.    loop  ;
  24.  
  25. : $E7  \ trap $C300 - clear the screen
  26.    cls clrText ;
  27.  
  28. : >text ( x y c -- ) \ put c in the text buffer
  29.    >r 4- dy / 1- swap 2- dx / 1- swap 50 * + r> swap theText + c! ;
  30.  
  31. : <del \ handle a backspace or delete character (Mops)
  32.    space space              \ clear underscore
  33.    @xy swap 12 - swap gotoxy        \ turn off cursor, back pen up
  34.    space @xy swap dx - swap 20 >text \ erase existing character if any
  35.    @xy swap 6 - swap gotoxy \ back up again
  36. ;
  37.  
  38. : ?scroll ( -- ) \ if the screen will scroll, kill top line in theText
  39.    @xy swap drop 101 = if killText then ;
  40.  
  41. : $F3  \ cout - output character in rA
  42.    @xy drop 1E8 = if ?scroll cr then \ cr if 80 characters out on this line
  43.    rA @ 7F and \ QForth sets hi bit, clear it
  44.    dup 7F = if drop <del else    \ delete
  45.    dup 08 = if drop <del else     \ backspace
  46.    dup 0d = if drop space ?scroll cr else \ return
  47.    dup 1F > if @xy rot dup emit >text else drop      \ alphanumeric
  48.    then then then then ;
  49.  
  50. : >hex ( h -- ) \ print a single hex digit
  51.    dup 9 > if 37 + rA ! $F3 else 30 + rA ! $F3 then ;
  52.  
  53. : $C7 \ hex - output character in rA as two hex digits
  54.    @xy drop 1E8 = if ?scroll cr then 
  55.    rA @ dup 10 / swap 10 mod swap >hex >hex ;
  56.  
  57. : $CB \ put a random number in FF8E and FF8F
  58.    100 random FF8F $! 100 random FF8E $! ;
  59.  
  60. : $BF \ put a random number on the stack from 0 to n-1
  61.    popQF random pushQF ;
  62.  
  63. : $BB { \ a b c -- } \ */ trap for scaled integer arithmetic
  64.    popQF  popQF  popQF  * swap /  pushQF ;
  65.  
  66. : $F7 \ output a cr
  67.     space ?scroll cr ;
  68.  
  69. : $FB \ get a key to rA
  70.    5F emit @xy swap 6 - swap gotoxy \ 5F = '_'
  71.    -1 -> ?waiting ; 
  72.  
  73. : $A7 \ KEY? trap, push true if a key pressed
  74.    ?terminal if FFFF pushQF else 0 pushQF then ;
  75.  
  76. : depthQF \ depth of QForth stack
  77.    F4 $@ ;
  78.  
  79. variable xGR
  80. variable yGR
  81. : putPen   \ restore graphics pen position
  82.    xGR @  yGR @  gotoxy ;
  83.  
  84. : savePen  \ store graphics pen position
  85.    @xy yGR ! xGR ! ;
  86.  
  87. : $EB \ LineTo
  88.    depthQF 1 > if  \ at least two values
  89.      @xy  putPen  \ save current position and move to old graphics position
  90.      popQF popQF swap lineto  \ move
  91.      savePen gotoxy  \ store new graphics position
  92.    then
  93. ;
  94.  
  95. : $EF \ MoveTo
  96.    depthQF 1 > if
  97.      @xy  putPen
  98.      popQF popQF swap gotoxy
  99.      savePen gotoxy
  100.    then
  101. ;
  102.  
  103. : red     0CD call ForeColor ;  \ Old-style colors
  104. : black    21 call ForeColor ;
  105. : yellow   45 call ForeColor ;
  106. : green   155 call ForeColor ;
  107. : blue    199 call ForeColor ;
  108. : white    1E call ForeColor ;
  109. : cyan    111 call ForeColor ;
  110. : magenta  89 call ForeColor ;
  111.  
  112. : $E3 \ set drawing color
  113.    depthQF 0 > if
  114.      popQF
  115.      dup 0 = if drop black else
  116.      dup 1 = if drop red   else
  117.      dup 2 = if drop green else
  118.      dup 3 = if drop blue  else
  119.      dup 4 = if drop cyan  else
  120.      dup 5 = if drop magenta else
  121.      dup 6 = if drop yellow else
  122.          7 = if drop white  else
  123.      black then then then then then then
  124.      then then then
  125. ;
  126.  
  127. : $D7 \ plot a point, faster than using QForth code
  128.    depthQF 1 > if
  129.      @xy popQF dup yGR ! popQF dup xGR ! swap
  130.      2dup gotoxy lineto
  131.      gotoxy
  132.    then
  133. ;
  134.  
  135. Mouse Mickey    \ a mouse object
  136.  
  137. : $D3 \ get mouse position and button status
  138.    get: Mickey  \ return button status and mouse position, x y b --
  139.    rot pushQF    \ push rX on QForth stack
  140.    swap pushQF    \ push rY on QForth stack
  141.    0= if 0 pushQF else FFFF pushQF then \ push button status on stack   
  142. ;
  143.  
  144. : $B3 \ 'type' trap
  145.    popQF popQF dup rot + swap do  i $@ rA ! $F3  loop ;
  146.  
  147. : $AF \ 'room' trap
  148.    09DFF  0E6 $@ 0E7 $@ 100 * +  -  pushQF ;
  149.  
  150. : $AB \ 'here' trap
  151.    0E6 $@ 0E7 $@ 100 * + 10 + pushQF ;
  152.  
  153.